Monster Media 1996 #15/Monster Media Number 15 (Monster Media)(July 1996).ISO/prog_d/subdatab.zip/D1UNIT1.PAS

Pascal/Delphi Source File | 1996-04-02 | 6KB | 277 lines

{$M 16384,8192}
unit D1unit1;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, StdCtrls, Buttons, Subdatab,

  demostat;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    OpenDialog1: TOpenDialog;
    Panel1: TPanel;
    Panel2: TPanel;
    Panel3: TPanel;
    Image1: TImage;
    Panel4: TPanel;
    BitBtn1: TBitBtn;
    Button6: TButton;
    Button7: TButton;
    ButtonStatus: TButton;
    ButtonReorg: TButton;
    SUBDataBase1: TSUBDataBase;
    procedure ButtonaddClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure ButtonStatusClick(Sender: TObject);
    procedure ButtondeleteClick(Sender: TObject);
    procedure SUBDataBase1Create(Sender: TObject);
    procedure Button_downClick(Sender: TObject);
    procedure Button_upClick(Sender: TObject);
    procedure ButtonReorgClick(Sender: TObject);
    procedure SUBDataBase1Reorg(Sender: TObject; ReorgAct: Longint);
  private
    { Private-Deklarationen }
    searchstring : String;
    procedure  GetDataRec;
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}


Type TIcoRecord = Record
       FName : String;
       FId   : Longint;
       FExt  : TExtension;
     end;

Const   Index_Filename  = 'FileName';


Function GetExtension ( Filename : String ) : TExtension;
  var Ext: TExtension;
      L: Integer;
begin
  L := Length(Filename);
  while (L > 0) and (Filename[L] <> '.') do Dec(L);
  Ext := '';
  if (Filename[L] = '.') and (Length(Filename) - L <= 3) then
    Ext := UpperCase(Copy(Filename, L + 1, 3));
  GetExtension := Ext;
end;




procedure TForm1.ButtonaddClick(Sender: TObject);

  var FN : String;
  var Stream : TMemoryStream;
  var BitMap : TBitMap;
      ICon   : TIcon;

      FIcoRecord : TIcoRecord;

      i : longint;

begin

  if OpenDialog1.Execute then  begin

    Try
      for i := 1 to OpenDialog1.Files.count do begin
        FN := uppercase(OpenDialog1.Files[pred(i)]);

        With FIcoRecord do begin
          FName := extractfilename(FN);
          FExt  := GetExtension(FName);
        end;

        Image1.Picture.LoadFromFile(FN);

        Stream := TMemoryStream.Create;

        With FIcoRecord do begin
          if FExt = 'BMP'
          then Image1.Picture.Bitmap.SaveToStream(Stream)
          else Image1.Picture.ICon.SaveToStream(Stream);
        end;


        {insert  the image}
        if not SUBDataBase1.addStream ( FIcoRecord.Fid , Stream  ) then begin
          Showmessage(' Daten nicht geschrieben! ');
          Exit;
        end;

        Stream.Free;

        searchstring  := lowercase( FIcoRecord.FName );

        {insert the Filename-Entry}
        Try
          SUBDataBase1.addData_Indexe ([Index_FileName],
                                       [searchstring],
                                       Sizeof(FIcoRecord),
                                       FIcoRecord);
        except
          {duplicate index, file exist in Database
           delete the image}
          SUBDataBase1.DeleteDataWithID  ( FIcoRecord.Fid );
          raise;
        end;

      end;
    finally
      getdatarec;
    end;
  end;
end;

{----------------------------------------------------------------}

procedure  TForm1.GetDataRec;
  var Stream : TMemoryStream;
      FIcoRecord : TIcoRecord;
begin

  if SUBDataBase1.DatenID = -1 then begin
    exit;
  end;
  SUBDataBase1.ReadActData (   Sizeof(FIcoRecord),
                     FIcoRecord);


  Stream := TMemoryStream.Create;
  if not SUBDataBase1.ReadStream ( FIcoRecord.Fid, Stream  ) then begin
    showmessage(' Daten nicht gelesen ');
  end;

  Stream.Position := 0;
  With FIcoRecord do begin
    if FExt = 'BMP'
    then Image1.Picture.BitMap.LoadFromStream(Stream)
    else  Image1.Picture.ICon.LoadFromStream(Stream);
  end;

  Stream.Free;

  panel1.caption := 'Records:'+inttostr(SUBDataBase1.CountKeys(Index_Filename ));
  panel2.caption := FIcoRecord.FName;

end;



procedure TForm1.FormCreate(Sender: TObject);
begin
  SUBDataBase1.open;

  searchstring  := '';

  {get first record}
  Button_downClick(NIL);

end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  SUBDataBase1.Close;
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
  close;
end;

procedure TForm1.ButtonStatusClick(Sender: TObject);
  Var SL : Tstringlist;
      F  : TStatusDialog;
begin
  SL := Tstringlist.create;
  SUBDataBase1.GetStatistik (SL);
  F  := TStatusDialog.create(NIL);
  Try
    f.memo1.lines := SL;
    f.showmodal;
  finally
    f.free;
    SL.free;
  end;
end;

procedure TForm1.ButtondeleteClick(Sender: TObject);

  var FIcoRecord : TIcoRecord;

begin
{-}

  if SUBDataBase1.DatenID = -1 then begin
    exit;
  end;

  SUBDataBase1.ReadActData (   Sizeof(FIcoRecord),
                     FIcoRecord);

  {delete the image}
  SUBDataBase1.DeleteDataWithID  ( FIcoRecord.Fid );

  {delete the Filename-Entry}
  SUBDataBase1.DeleteDataWithIndex( Index_Filename,lowercase(FIcoRecord.FName ));
  Button_downClick(NIL);
  if SUBDataBase1.DatenID = -1 then begin
    Button_upClick(NIL);
  end;

end;

procedure TForm1.SUBDataBase1Create(Sender: TObject);
begin
  SUBDataBase1.createIndex (Index_Filename , 60, false);
                                             {indexlength, duplicate}
end;

procedure TForm1.Button_downClick(Sender: TObject);
begin
  searchstring  := SUBDataBase1.NextIndex (Index_filename,searchstring);
  getdatarec;
end;

procedure TForm1.Button_upClick(Sender: TObject);
begin
  searchstring  := SUBDataBase1.PrevIndex (Index_filename,searchstring);
  getdatarec;
end;


procedure TForm1.ButtonReorgClick(Sender: TObject);
begin
  Subdatabase1.Reorganisation;
end;

procedure TForm1.SUBDataBase1Reorg(Sender: TObject; ReorgAct: Longint);
begin

  panel1.caption := 'reorg: '+inttostr(ReorgAct)+' until: '+
    inttostr(SUBDataBase1.Reorgmax);

  Application.processmessages;

end;

end.